;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;font-menus.lisp
;;  copyright © 1987-89 Apple Computer
;;
;;
;;  this file defines a set of hierarchical menus which can be used for
;;  setting the font of the current window.
;;
;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  define some variables for holding the menus
;;

(defparameter *font-menu* (oneof *menu* :menu-title "Font"))
(defparameter *font-size-menu* (oneof *menu* :menu-title "Font Size"))
(defparameter *font-style-menu* (oneof *menu* :menu-title "Font Style"))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  create a new class of menu-items for setting font attribute.
;;
;;  each menu-item has a title, and an attribute.  When the item is
;;  selected, it asks the top window to set-window-font to the attribute.
;;  In this way, there is only one action for the whole class.  (Each instance
;;  doesn't need its own action.  Each one just needs its own attribute).
;;
;;  The fact that the attribute is just like the name of the menu item
;;  is also convenient.
;;

(defobject *font-menu-item* *menu-item*)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  the exist procedure gets the attribute, and then calls usual exist
;;

(defobfun (exist *font-menu-item*) (init-list)
  (have 'my-attribute (getf init-list :attribute *fred-default-font-spec*))
  (usual-exist init-list))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  the menu-item-action asks the front window to set its window-font
;;  to the menu-item's attribute.
;;

(defobfun (menu-item-action *font-menu-item*) ()
  (let ((the-attribute my-attribute))
    (ask (front-window) (set-window-font the-attribute))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  here we set up the font menu.  We make an item for each font listed
;;  in the global variable *font-list*.  In this case, the menu-item name
;;  and the attribute are exactly the same (a string giving the name of a
;;  font).
;;
;;  We process the *font-list* to remove fonts that begin with a "%",
;;  because these aren't meant to be displayed in font menus.
;;

(ask *font-menu*
  (dolist (font-name (remove #\% *font-list*
                               :key #'(lambda (string)
                                          (elt string 0))))
    (add-menu-items (oneof *font-menu-item*
                           :menu-item-title font-name
                           :attribute font-name))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  here we set up the font size menu.  Each menu-item has a number
;;  for it's attribute.  To get the name of the menu-item, we just print
;;  the number into a string using the function FORMAT.
;;

(ask *font-size-menu*
  (dolist (font-size '(9 10 12 14 18 24))
    (add-menu-items (oneof *font-menu-item*
                           :menu-item-title (format nil "~a" font-size)
                           :attribute font-size))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  here we set up the font style menu.  In this case it's easiest to just
;;  give the attribute explicitly.
;;
;;  Once the menu-items are set up, we ask them to change their font style,
;;  so that they are displayed in the style they represent.
;;
(ask *font-style-menu*
    (add-menu-items
      (oneof *font-menu-item* :menu-item-title "Plain" :attribute :plain)
      (oneof *font-menu-item* :menu-item-title "Bold" :attribute :bold)
      (oneof *font-menu-item* :menu-item-title "Italic" :attribute :italic)
      (oneof *font-menu-item* :menu-item-title "Underline" :attribute :underline)
      (oneof *font-menu-item* :menu-item-title "Outline" :attribute :outline)
      (oneof *font-menu-item* :menu-item-title "Shadow" :attribute :shadow)
      (oneof *font-menu-item* :menu-item-title "Condense" :attribute :condense)
      (oneof *font-menu-item* :menu-item-title "Extend" :attribute :extend))
    (dolist (menu-item (menu-items))
      (ask menu-item (set-menu-item-style my-attribute))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  now that we have all the menus, we just add them to the *edit-menu*
;;  (preceded by a blank-line menu-item).
;;

(ask *edit-menu* 
  (add-menu-items
   (oneof *menu-item* :menu-item-title "-")         ;a blank line
   *font-menu* *font-size-menu* *font-style-menu*))
